home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / root.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-07-23  |  14.2 KB  |  573 lines
  1. /* ******************************************************************** */
  2. /*  root.c           Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* The root level operations                                        */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * Change Log:
  9.  *   Version 1, March 1990 (Compiler rationalisation)
  10.  */
  11.  
  12. #include <stdio.h>
  13. #include <string.h>
  14.  
  15. #include "funcalls.h"
  16. #include "defs.h"
  17. #include "structs.h"
  18.  
  19. #include "error.h"
  20. #include "global.h"
  21. #include "slots.h"
  22. #include "table.h"
  23. #include "garbage.h"
  24.  
  25. #include "allocate.h"
  26. #include "modboot.h"
  27. #include "symboot.h"
  28. #include "modules.h"
  29. #include "toplevel.h"
  30. #include "root.h"
  31. #include "copy.h"
  32. #include "streams.h"
  33. #include "reader.h"
  34.  
  35. #define ROOT_ENTRIES 12
  36. MODULE Module_root;
  37. LispObject Module_root_values[ROOT_ENTRIES];
  38.  
  39. static SYSTEM_GLOBAL(LispObject,list_search_path);
  40. static SYSTEM_GLOBAL(int,load_verbosity);
  41.  
  42. static LispObject sym_eval_cm,sym_set_cm;
  43. static LispObject Cb_load_user_module;
  44.  
  45. EUFUN_2( eval_cm_template, env, form)
  46. {
  47.   return(EUCALL_3(module_eval,env->ENV.value,NULL,form));
  48. }
  49. EUFUN_CLOSE
  50.  
  51. EUFUN_3( set_cm_template, env, sym, val)
  52. {
  53.   if (!is_symbol(sym))
  54.     CallError(stacktop,"set/cm: not a symbol",sym,NONCONTINUABLE);
  55.   printf("No set/cm yet...\n");
  56.   (void) EUCALL_3(module_set,(env)->ENV.value,sym,val);
  57.  
  58.   return(val);
  59. }
  60. EUFUN_CLOSE
  61.  
  62. void make_default_module_functions(LispObject *stacktop,LispObject mod)
  63. {
  64.   LispObject f;
  65.  
  66.   STACK_TMP(mod);
  67.   f = make_anonymous_module_env_function_1(stacktop,mod,eval_cm_template,1,
  68.                        sym_nil,mod);
  69.   UNSTACK_TMP(mod);
  70.   STACK_TMP(mod);
  71.   (void) module_set_new(stacktop,mod,sym_eval_cm,f);        
  72.   UNSTACK_TMP(mod);
  73.   STACK_TMP(mod);
  74.   f = make_anonymous_module_env_function_1(stacktop,mod,set_cm_template,2,
  75.                        sym_nil,mod);
  76.   UNSTACK_TMP(mod);
  77.   (void) module_set_new(stacktop,mod,sym_set_cm,f);
  78.  
  79. }
  80.  
  81. EUFUN_3( Rf_defmodule, mod, env, forms)
  82. {
  83.   LispObject name,import_specs,syntax_specs;
  84.   LispObject module,tmp;
  85.   LispObject walker;
  86.   LispObject new_initargs=nil;
  87.  
  88.   if (!is_cons(forms))
  89.     CallError(stacktop,"defmodule: missing name",nil,NONCONTINUABLE);
  90.  
  91.   name = CAR(forms); forms = CDR(forms);
  92.  
  93.   if (!is_symbol(name))
  94.     CallError(stacktop,"defmodule: non-symbolic name",name,NONCONTINUABLE);
  95.  
  96.   /* Overwrite existing one... */ /* HACK !!! */
  97.  
  98.   if (!is_cons(forms))
  99.     CallError(stacktop,"defmodule: missing import specs",nil,NONCONTINUABLE);
  100.  
  101.   import_specs = CAR(forms); forms = CDR(forms);
  102.  
  103.   if (!is_cons(import_specs) && import_specs != nil)
  104.     CallError(stacktop,
  105.           "defmodule: bad import spec",import_specs,NONCONTINUABLE);
  106.  
  107.   walker=import_specs;
  108.   while (walker!=nil)
  109.     { /* new syntax ? --- this is not very extensible, 
  110.      just bomb when we get 'import thing.  */
  111.       if (CAR(walker)==sym_import)
  112.     {
  113.       new_initargs=import_specs;
  114.       import_specs=CAR(CDR(walker));
  115.       break;
  116.     }
  117.       else /* (cdr nil)=nil */
  118.     walker=CDR(CDR(walker));
  119.     }
  120.   
  121.   if (new_initargs!=nil) 
  122.     {    
  123.       /*syntax_specs=search_keylist(stacktop,new_initargs,sym_syntax);*/
  124.       syntax_specs=nil;
  125.     }
  126.   else
  127.     {
  128.  
  129.       if (!is_cons(forms))
  130.     CallError(stacktop,"defmodule: missing syntax spec",nil,NONCONTINUABLE);
  131.       syntax_specs = CAR(forms); 
  132.       forms = CDR(forms);
  133.     }
  134.   /* See what sort of syntax we have..*/
  135.  
  136.   if (syntax_specs != nil)
  137.     CallError(stacktop,
  138.           "defmodule: non-null syntax spec",syntax_specs,NONCONTINUABLE);
  139.   
  140.   /* Should do the loading here maybe... */ /* HACK !!! */
  141.   STACK_TMP(name); 
  142.   STACK_TMP(forms);
  143.   STACK_TMP(import_specs);
  144.   module = allocate_i_module(stacktop,name);
  145.   STACK_TMP(module);
  146.   tmp=EUCALL_1(make_table,NULL);
  147.   UNSTACK_TMP(module);
  148.   module->I_MODULE.bindings=tmp;
  149.   /* Insert eval/cm and set/cm... */
  150.   STACK_TMP(module);
  151.   make_default_module_functions(stacktop,module);
  152.   UNSTACK_TMP(module);
  153.   /* recover import spec, etc */
  154.   UNSTACK_TMP(import_specs);
  155.   STACK_TMP(module);
  156.   process_import_spec(stacktop,module,import_specs);
  157.  
  158.   UNSTACK_TMP(module);
  159.   UNSTACK_TMP(forms);
  160.   walker=forms;
  161.   while (walker != nil)
  162.     {
  163.       if (SYSTEM_GLOBAL_VALUE(load_verbosity) > 0 && StdOut()!=nil)
  164.     {
  165.       STACK_TMP(walker);
  166.       STACK_TMP(module);
  167.       print_string(stacktop,StdOut(),"Processing: ");
  168.       EUCALL_2(Fn_print, CAR(walker),StdOut());
  169.       UNSTACK_TMP(module);
  170.       UNSTACK_TMP(walker);
  171.     }
  172.       STACK_TMP(CDR(walker));
  173.       STACK_TMP(module);    
  174.       EUCALL_2(process_top_level_form,module,CAR(walker));
  175.       UNSTACK_TMP(module);
  176.       UNSTACK_TMP(walker);
  177.     }
  178.   UNSTACK_TMP(name);
  179.   STACK_TMP(module);
  180.   put_module(stacktop,name,module);
  181.   UNSTACK_TMP(module);
  182.   return(module);
  183. }
  184. EUFUN_CLOSE
  185.  
  186. EUFUN_3( Rf_loaded_modules, mod, env, val)
  187. {
  188.   LispObject lst,val;
  189. /**
  190.   *return(EUCALL_1(Fn_table_keys, global_module_table));    
  191.   */
  192.   
  193.   val=EUCALL_1(Fn_table_parameters,global_module_table);
  194.   lst=val;
  195.   while (lst!=nil)
  196.     {    
  197.       CAR(lst)=CAR(CAR(lst));
  198.       lst=CDR(lst);
  199.     }
  200.   return val;
  201. }
  202. EUFUN_CLOSE
  203.  
  204. EUFUN_3( Rf_load_module, mod, env, form)
  205. {
  206.   IGNORE(mod); IGNORE(env);
  207.  
  208.   if (!is_cons(form))
  209.     CallError(stacktop,"load-module: invalid arguments",form,NONCONTINUABLE);
  210.   RESET_GLOBAL_STACK();
  211.   return(EUCALL_1(load_module,CAR(form)));
  212. }
  213. EUFUN_CLOSE
  214.  
  215. EUFUN_3( Rf_reload_module, mod, env, form)
  216. {
  217.   IGNORE(mod); IGNORE(env);
  218.  
  219.   if (!is_cons(form))
  220.     CallError(stacktop,"reload-module: invalid arguments",form,NONCONTINUABLE);
  221.  
  222.   /* Hack out original... */
  223.  
  224.   EUCALL_3(Fn_table_ref_setter, global_module_table,CAR(form),nil);
  225.   return(EUCALL_1(load_module,CAR(ARG_2(stackbase))));
  226. }
  227. EUFUN_CLOSE
  228.  
  229. static FILE *open_module_file(LispObject *stacktop,LispObject name)
  230. {
  231.   char path[200];
  232.   LispObject walker;
  233.   FILE *fd;
  234.  
  235.   if (!is_symbol(name))
  236.     CallError(stacktop,
  237.           "open-module-file: not a symbolic name",name,NONCONTINUABLE);
  238.  
  239.   walker = SYSTEM_GLOBAL_VALUE(list_search_path);
  240.   while (is_cons(walker)) {
  241.     LispObject dir;
  242.  
  243.     if (!is_string((dir = CAR(walker))))
  244.       CallError(stacktop,
  245.         "open-module-file: bad search directory",dir,NONCONTINUABLE);
  246.  
  247.     (void) strcpy(path,stringof(dir));
  248.     (void) strcat(path,DIR_SEP);
  249.     (void) strcat(path,stringof(name->SYMBOL.pname));
  250.     (void) strcat(path,".em");
  251.  
  252.     if ((fd = fopen(path,"r")) == NULL)
  253.       walker = CDR(walker);
  254.     else
  255.       return fd;
  256.   }
  257.  
  258.   CallError(stacktop,"open-module-file: unable to find .em file for module",
  259.         name,NONCONTINUABLE);
  260.  
  261.   return(NULL); /* Not ever */
  262. }
  263.   
  264. EUFUN_1( load_module, name)
  265. {
  266.   char fname[100];
  267.   LispObject form,ans;
  268.   FILE *stream;
  269.  
  270.   if (!is_symbol(name)) 
  271.     CallError(stacktop,
  272.           "load-module: non-symbolic module name",name,NONCONTINUABLE);
  273.  
  274.   /* Look if it's already loaded */
  275.  
  276.   if (module_loaded_p(stacktop,name)) return(get_module(stacktop,name));
  277.  
  278.   stream = open_module_file(stacktop,name);
  279.   
  280.   name=ARG_0(stackbase);
  281.   print_string(stacktop,StdOut(),"Loading module '");
  282.   print_string(stacktop,StdOut(),stringof(name->SYMBOL.pname));
  283.   print_string(stacktop,StdOut(),"'\n");
  284.  
  285.   form=sys_read(stacktop, stream);
  286.  
  287.   reader_fclose(stacktop,stream);
  288.   
  289.   if (!is_cons(form))
  290.     CallError(stacktop,
  291.           "load module: invalid module definition",nil,NONCONTINUABLE);
  292.  
  293.   if (CAR(form) != sym_defmodule) 
  294.     CallError(stacktop,
  295.           "load module: invalid module definition",nil,NONCONTINUABLE);
  296.  
  297.   if(!is_cons(CDR(form)))
  298.     CallError(stacktop,
  299.           "load module: invalid definintion",form,NONCONTINUABLE);
  300.  
  301.   name=ARG_0(stackbase);
  302.   if (CAR(CDR(form)) != name)
  303.     CallError(stacktop,
  304.           "load module: module badly named",CAR(CDR(form)),NONCONTINUABLE);
  305.  
  306.   EUCALLSET_3(ans,Rf_defmodule,NULL,NULL,CDR(form));
  307.   
  308.   name=ARG_0(stackbase);
  309.   print_string(stacktop,StdOut(),"Loaded '");
  310.   print_string(stacktop,StdOut(),stringof(name->SYMBOL.pname));
  311.   print_string(stacktop,StdOut(),"'\n");
  312.  
  313.   return(ans);
  314. }
  315. EUFUN_CLOSE
  316.  
  317. LispObject load_expanded_module(LispObject *stacktop,LispObject name)
  318. {
  319.   char fname[100];
  320.   LispObject form;
  321.   FILE *stream;
  322.  
  323.   if (!is_symbol(name)) 
  324.     CallError(stacktop,
  325.           "load-expanded-module: non-symbolic module name",name,NONCONTINUABLE);
  326.  
  327.   /* Look if it's already loaded */
  328.  
  329.   if (module_loaded_p(stacktop,name)) return(get_module(stacktop,name));
  330.  
  331.   stream = open_module_file(stacktop,name);
  332.  
  333.   print_string(stacktop,StdOut(),"Loading module '");
  334.   print_string(stacktop,StdOut(),stringof(name->SYMBOL.pname));
  335.   print_string(stacktop,StdOut(),"'\n");
  336.  
  337.   STACK_TMP(form);
  338.   form=sys_read(stacktop,stream);
  339.   UNSTACK_TMP(form);
  340.  
  341.   reader_fclose(stacktop,stream);
  342.  
  343.   if (!is_cons(form))
  344.     CallError(stacktop,
  345.           "load module: invalid module definition",nil,NONCONTINUABLE);
  346.  
  347.   if (CAR(form) != sym_defmodule) 
  348.     CallError(stacktop,
  349.           "load module: invalid module definition",nil,NONCONTINUABLE);
  350.  
  351.   if(!is_cons(CDR(form)))
  352.     CallError(stacktop,
  353.           "load module: invalid definintion",form,NONCONTINUABLE);
  354.  
  355.   if (CAR(CDR(form)) != name)
  356.     CallError(stacktop,
  357.           "load module: module badly named",CAR(CDR(form)),NONCONTINUABLE);
  358.  
  359.   return EUCALL_3(Rf_defmodule,NULL,NULL,CDR(form));
  360. }
  361.  
  362. EUFUN_3( Rf_load_expanded_module, mod, env, forms)
  363. {
  364.   if (!is_cons(forms))
  365.     CallError(stacktop,
  366.           "load-expanded-module: invalid arguments",forms,NONCONTINUABLE);
  367.  
  368.   return(load_expanded_module(stacktop,CAR(forms)));
  369. }
  370. EUFUN_CLOSE
  371.  
  372. EUFUN_3( Rf_start_module, m, env, forms)
  373. {
  374.   LispObject modname,fname;
  375.   LispObject mod;
  376.  
  377.   if (!is_cons(forms))
  378.     CallError(stacktop,"start-module: invalid arguments",forms,NONCONTINUABLE);
  379.  
  380.   modname = CAR(forms); forms = CDR(forms);
  381.  
  382.   if (!is_symbol(modname))
  383.     CallError(stacktop,
  384.           "start-module: non-symbolic module name",modname,NONCONTINUABLE);
  385.  
  386.   if (!is_cons(forms))
  387.     CallError(stacktop,
  388.           "start-module: missing function name",forms,NONCONTINUABLE);
  389.  
  390.   fname = CAR(forms);
  391.  
  392.   if (!is_symbol(fname))
  393.     CallError(stacktop,
  394.           "start-module: non-symbolic function name",fname,NONCONTINUABLE);
  395.  
  396.   /* forms are hopefully (fname arg1 arg2 ...) */
  397.  
  398.   /* semantically dubious but... */
  399.  
  400.   mod = get_module(stacktop,modname);
  401.  
  402.   if (mod == nil)
  403.     CallError(stacktop,
  404.           "start-module: module not loaded",modname,NONCONTINUABLE);
  405.  
  406.   return(EUCALL_3(module_eval,mod,NULL,forms));
  407. }
  408. EUFUN_CLOSE
  409.  
  410. EUFUN_3( Rf_enter_module, m, env, form)
  411. {
  412.   LispObject name;
  413.   LispObject mod;
  414.  
  415.   if (!is_cons(form))
  416.     CallError(stacktop,"enter-module: invalid arguments",form,NONCONTINUABLE);
  417.  
  418.   name = CAR(form);
  419.   if (!is_symbol(name))
  420.     CallError(stacktop,
  421.           "enter-module: non-symbolic module name",name,NONCONTINUABLE);
  422.  
  423.   else {
  424.     mod = get_module(stacktop,name);
  425.     STACK_TMP(name);
  426.     if (mod == nil)
  427.       SYSTEM_GLOBAL_VALUE(current_interactive_module) =
  428.     EUCALL_1(load_module,name);
  429.     else
  430.       SYSTEM_GLOBAL_VALUE(current_interactive_module) = mod;
  431.     UNSTACK_TMP(name);
  432.   }
  433.  
  434.   return(name);
  435. }
  436. EUFUN_CLOSE
  437.  
  438. EUFUN_0( Rf_load_quietly)
  439. {
  440.   SYSTEM_GLOBAL_VALUE(load_verbosity) = 0;
  441.   return(nil);
  442. }
  443. EUFUN_CLOSE
  444.  
  445. EUFUN_0( Rf_load_loudly)
  446. {
  447.   SYSTEM_GLOBAL_VALUE(load_verbosity) = 1;
  448.   return(nil);
  449. }
  450. EUFUN_CLOSE
  451.  
  452. static EUFUN_0( Fn_load_path)
  453. {
  454.   return(SYSTEM_GLOBAL_VALUE(list_search_path));
  455. }
  456. EUFUN_CLOSE
  457.  
  458. static EUFUN_1( Fn_load_path_setter, val)
  459. {
  460.   return((SYSTEM_GLOBAL_VALUE(list_search_path) = val));
  461. }
  462. EUFUN_CLOSE
  463.  
  464. static EUFUN_3( Rf_em, m, e, f)
  465. {
  466.   return Rf_enter_module(stackbase);
  467. }
  468. EUFUN_CLOSE
  469.  
  470. static EUFUN_3( Rf_rem, m, e, f)
  471. {
  472.   EUCALL_3(Rf_reload_module,m,e,f);
  473.   return Rf_enter_module(stackbase);
  474. }
  475. EUFUN_CLOSE
  476.  
  477. /* Enter user module */
  478. static EUFUN_3( Rf_eum, m, e, f)
  479. {
  480.   if (CAR(Cb_load_user_module)==nil)
  481.     Rf_em(stackbase);
  482.   EUCALL_2(apply1, CAR(Cb_load_user_module), CAR(f));
  483.   
  484.   return Rf_enter_module(stackbase);
  485. }
  486. EUFUN_CLOSE
  487.  
  488. static EUFUN_1( Fn_set_eum_fn, fn)
  489. {
  490.   CAR(Cb_load_user_module)=fn;
  491.   return nil;
  492. }
  493. EUFUN_CLOSE
  494.  
  495. void initialise_root(LispObject* stacktop)
  496. {
  497.   extern char *getenv(char *);
  498.   extern LispObject Fn_nconc(LispObject*);
  499.   char *path_list;
  500.   
  501.   SYSTEM_INITIALISE_GLOBAL(int,load_verbosity,0);
  502.   SYSTEM_INITIALISE_GLOBAL(LispObject,list_search_path,nil);
  503.  
  504.   ADD_SYSTEM_GLOBAL_ROOT(list_search_path);
  505.   
  506.   Cb_load_user_module=EUCALL_2(Fn_cons, nil, nil);
  507.   add_root(&Cb_load_user_module);
  508.  
  509.   /* Initialise the paths... */
  510.   
  511.   path_list = getenv(LOAD_PATH_NAME);
  512.  
  513.   if (path_list == NULL) {
  514.     SYSTEM_GLOBAL_VALUE(list_search_path) 
  515.       = EUCALL_2(Fn_cons,
  516.          allocate_string(stacktop,MODULE_PATH,strlen(MODULE_PATH)),
  517.          SYSTEM_GLOBAL_VALUE(list_search_path));
  518.     SYSTEM_GLOBAL_VALUE(list_search_path) 
  519.       = EUCALL_2(Fn_cons, allocate_string(stacktop,".",1),
  520.          SYSTEM_GLOBAL_VALUE(list_search_path));
  521.   }
  522.   else {
  523.     char *next;
  524.  
  525.     next = strtok(path_list,":");
  526.     while (next != NULL) {
  527.       LispObject xx;
  528.       xx = allocate_string(stacktop,next,strlen(next));
  529.       EUCALLSET_2(xx, Fn_cons, xx,nil);
  530.       EUCALLSET_2(SYSTEM_GLOBAL_VALUE(list_search_path), 
  531.           Fn_nconc,SYSTEM_GLOBAL_VALUE(list_search_path), xx);
  532.       next = strtok(NULL,":");
  533.     }
  534.   }
  535.  
  536.   sym_eval_cm = get_symbol(stacktop,"eval/cm");    
  537.   add_root(&sym_eval_cm);
  538.   sym_set_cm = get_symbol(stacktop,"set/cm");
  539.   add_root(&sym_set_cm);
  540.   {
  541.     extern LispObject my_make_special(LispObject *,char *,LispObject (*)());
  542.  
  543.     (void) my_make_special(stacktop,"!>",Rf_em);
  544.     (void) my_make_special(stacktop,"!>>",Rf_rem);
  545.     (void) my_make_special(stacktop,"!!>",Rf_eum);
  546.   }
  547.  
  548.   open_module(stacktop,&Module_root,Module_root_values,"root",ROOT_ENTRIES);
  549.  
  550.   (void) make_unexported_module_special(stacktop,"defmodule",Rf_defmodule);
  551.   (void) make_unexported_module_special(stacktop,"load-module",Rf_load_module);
  552.   (void) make_unexported_module_special(stacktop,
  553.                     "reload-module",Rf_reload_module);
  554.   (void) make_unexported_module_special(stacktop,
  555.                     "enter-module",Rf_enter_module);
  556.   (void) make_unexported_module_special(stacktop,
  557.                     "loaded-modules",Rf_loaded_modules);
  558.   (void) make_unexported_module_special(stacktop,
  559.                     "start-module",Rf_start_module);
  560.   (void) make_unexported_module_special(stacktop,"load-expanded-module",
  561.                     Rf_load_expanded_module);
  562.   (void) make_unexported_module_special(stacktop,
  563.                     "load-quietly",Rf_load_quietly);
  564.   (void) make_unexported_module_special(stacktop,"load-loudly",Rf_load_loudly);
  565.  
  566.   (void) make_unexported_module_function(stacktop,"load-path",Fn_load_path,0);
  567.   (void) make_unexported_module_function(stacktop,"set-load-path",
  568.                      Fn_load_path_setter,1);
  569.   (void) make_module_function(stacktop,"set-eum-function",Fn_set_eum_fn,1);
  570.  
  571.   close_module();
  572. }
  573.